home *** CD-ROM | disk | FTP | other *** search
/ Developer CD Series 1996 May: Tool Chest / Developer CD Series May 1996 (Tool Chest) (Apple Computer) (1996).iso / Tool Chest / Development Tools & Languages / Macintosh Common Lisp Related / 2.01 sources / Examples-2.01 / mouse-copy.lisp < prev    next >
Encoding:
Text File  |  1993-09-16  |  9.1 KB  |  228 lines  |  [TEXT/CCL2]
  1. ;;-*- Mode: Lisp; Package: CCL -*-
  2. ;; ****************************************************************
  3. ;; code to implement command-click. 
  4. ;; Command Click copies what you are pointing to where you are typing.
  5.  
  6. ;; Implementation:
  7.  
  8. ;; Each type to view which wants to be able to contribute text defines two methods
  9. ;; (give-text? view)   -> t if you can supply text
  10. ;; (give-text view)    -> The text which is to be copied.
  11.  
  12. ;; Additionally the view-click-event-handler should arrange to call
  13. ;; (maybe-click-to-copy from-window to-window position continuation)
  14. ;; where continuation is called if the click wasn't a command click,
  15. ;; or if it was but there was no text to copy.
  16.  
  17. ;; Currently the methods for editable-text, dialog-item, sequence-dialog-item, and fred-mixin do this by
  18. ;; advising the around method for view-click-event-handler.
  19. ;; Also, the window-select-event-handler is also advised, so that you can command click another to copy from
  20. ;; another window.
  21.  
  22. ;; ****************************************************************
  23.  
  24. ;; Change log
  25. ;;
  26. ;; 04/28/93 mwp Release
  27. ;; 03/19/93 bill  missing paren in my translation of MC's fix of 7/29/92
  28. ;; 07/29/92 mc    Fixed menu-of-defs-dialog's give-text to handle null
  29. ;;                window-package (mc = Matt Cornell, cornell@cs.umass.edu)
  30. ;; -------------- 2.0
  31. ;; 03/17/92 bill  the menu-of-defs-dialog code no longer replaces
  32. ;;                the sequence-dialog-item code.
  33. ;; -------------- 2.0f3
  34. ;; 10/04/91 alanr Support the list definitions dialog
  35. ;; 09/13/91 alice make buffer-insert-carefully undo aware
  36. ;; 04/18/91 wkf  Fix to avoid error when you click where there is no text.
  37. ;; 01/01/91 bill  Prettify, remove LOOP
  38. ;; 12/11/90 alice fix calls to advise for changed arglist
  39. ;; 11/05/90 bill Remove reliance on (declaim (ignore ignore))
  40.  
  41. (in-package :ccl)
  42.  
  43. (defmethod give-text ((v t)) nil)
  44. (defmethod give-text? ((v t)) nil)
  45.  
  46. (defmethod insert-text ((v t) ignore)
  47.   (declare (ignore ignore))
  48.   nil)
  49. (defmethod insert-text ((v fred-mixin) string)
  50.   (buffer-insert-carefully v string)
  51.   (fred-update v))
  52.  
  53. (defmethod buffer-insert-carefully ((w fred-mixin) string
  54.                                     &aux (mark (fred-buffer w)) position append)
  55.   "Insert spaces around insertion, if absent"
  56.   (multiple-value-bind (s e) 
  57.                        (selection-range w)
  58.     (when (collapse-selection w t)
  59.       (setq append t)
  60.       (ed-delete-with-undo w e s)))
  61.   (setq position (buffer-position mark))
  62.   (unless (or (eql position (buffer-line-start mark position))
  63.               (not (alphanumericp (buffer-char mark (1- position)))))
  64.     (ed-insert-with-undo w " " position append)
  65.     (setq append t)
  66.     (incf position))
  67.   (unless (or (eql position (buffer-line-end mark position))
  68.               (not (alphanumericp (buffer-char mark position))))
  69.     (ed-insert-with-undo  w " " position append)
  70.     (setq append t))
  71.   (ed-insert-with-undo w string position append))
  72.  
  73. (defun maybe-click-to-copy (from to where &optional (continue 'identity))
  74.   (let* ((w (view-window to))
  75.          (insert-into (or (current-key-handler (view-window to))  (and (typep (view-window to) 'fred-window) w))))
  76.     (if insert-into
  77.       (if (and (command-key-p) (not (or (control-key-p) (shift-key-p) (option-key-p))))
  78.         (let ((give-text (deepest-give-text-below-mouse from where)))
  79.           (if (and insert-into give-text)
  80.             (insert-text insert-into give-text)
  81.             (funcall continue)))
  82.         (funcall continue))
  83.       (funcall continue))))
  84.  
  85. (defmethod current-key-handler ((view t)) nil)
  86.  
  87. (unless
  88.   (ignore-errors (find-method #'view-click-event-handler '(:around) (mapcar 'find-class '(fred-mixin t))))
  89.   (defmethod view-click-event-handler :around ((view fred-mixin) ignore)
  90.     (declare (ignore ignore))
  91.     (when (next-method-p) (call-next-method))))
  92.  
  93. (unless
  94.   (ignore-errors (find-method #'view-click-event-handler '(:around) (mapcar 'find-class '(dialog-item t))))
  95.   (defmethod view-click-event-handler :around ((view dialog-item) ignore)
  96.     (declare (ignore ignore))
  97.     (when (next-method-p) (call-next-method))))
  98.  
  99. (advise window-select-event-handler
  100.         (maybe-click-to-copy (car arglist) (front-window)
  101.                              (view-mouse-position (car arglist)) #'(lambda ()(:do-it)))
  102.         :when :around :name maybe-copy)
  103.  
  104. (advise (:method view-click-event-handler :around (fred-mixin t))
  105.         (destructuring-bind (v where) arglist
  106.           (maybe-click-to-copy v v where #'(lambda() (:do-it))))
  107.         :when :around :name maybe-click-to-copy)
  108.  
  109. (advise (:method view-click-event-handler :around (dialog-item t))
  110.         (destructuring-bind (v where) arglist
  111.           (maybe-click-to-copy v v (convert-coordinates where (view-container v) v) #'(lambda () (:do-it))))
  112.         :when :around :name maybe-click-to-copy)
  113.  
  114. (defmethod deepest-give-text-below-mouse ((v simple-view) position &aux w)
  115.   (declare (optimize (speed 3) (safety 0)))
  116.   (setq w (view-window v))
  117.   (setq position (convert-coordinates position v w))
  118.   (rlet ((r :rect))
  119.     (labels ((deepest 
  120.               (v^)
  121.               (rset r rect.topleft (convert-coordinates #@(0 0) v^ w))
  122.               (rset r rect.bottomright (convert-coordinates (view-size v^) v^ w))
  123.               (let ((res (and (#_ptinrect position r)
  124.                               (let ((lower (do-subviews (s v^)
  125.                                              (let ((d (deepest s)))
  126.                                                (when d (return d))))))
  127.                                 (or lower
  128.                                     (and (give-text? v^) v^))))))
  129.                 res
  130.                 )))
  131.       (give-text (deepest w)))))
  132.  
  133. ;; ****************************************************************
  134. ;; support for some view types
  135.  
  136. ;; fred mixins
  137.  
  138. (defmethod give-text? ((v fred-mixin)) t)
  139. (defmethod give-text ((v fred-mixin))
  140.   (let ((buffer (fred-buffer v)))
  141.     (multiple-value-bind (start end) 
  142.                          (buffer-current-sexp-bounds
  143.                           buffer
  144.                           (fred-point-position v (view-mouse-position v) ))
  145.       (if start
  146.         (buffer-substring buffer start end)
  147.         ""))))
  148.  
  149. ;; sequence dialog items
  150. (defmethod give-text? ((v sequence-dialog-item))
  151.   (not (typep (view-container v) 'menu-of-defs-dialog)))
  152. (defmethod give-text ((v sequence-dialog-item))
  153.   (let ((cell (point-to-cell v (view-mouse-position (view-container v)))))
  154.     (when cell
  155.       (setq * (cell-contents v cell))
  156.       (format nil "~s" (cell-contents v cell)))))
  157.  
  158. ;; editable-text-dialog-items
  159. (defmethod give-text? ((v basic-editable-text-dialog-item)) t)
  160. (defmethod give-text ((v basic-editable-text-dialog-item))
  161.   (let ((buffer (fred-buffer v)))
  162.     (multiple-value-bind 
  163.       (start end) 
  164.       (buffer-current-sexp-bounds buffer (fred-point-position v (view-mouse-position v) ))
  165.       (buffer-substring buffer start end))))
  166.  
  167. ;; dialog items return their text
  168.  
  169. (defmethod give-text? ((v dialog-item)) t)
  170. (defmethod give-text ((v dialog-item)) 
  171.   (dialog-item-text v))
  172.  
  173. ;; get the right line from the inspector
  174.  
  175. (defmethod clicked-on-selection ((view inspector::inspector-view) where)
  176.   (let ((v (point-v where))
  177.         (line-positions (inspector::line-positions view))
  178.         temp
  179.         new-selection)
  180.     (when line-positions
  181.       (setq temp (aref line-positions 0))
  182.       (dotimes (i (1- (length line-positions)))
  183.         (when (and (<= temp v)
  184.                    (< v (setq temp (aref line-positions (1+ i)))))
  185.           (let ((selection (+ (inspector::start-line view) i)))
  186.             (unless (eq (inspector::cached-type-n view selection) :comment)
  187.               (setq new-selection selection)
  188.               (return))))))
  189.     new-selection))
  190.  
  191. (defmethod give-text ((view inspector::inspector-view))
  192.   (let ((object (inspector::cached-line-n view (clicked-on-selection view (view-mouse-position view)))))
  193.     (setq * object)
  194.     (prin1-to-string object)
  195.     ))
  196.  
  197. (defmethod view-click-event-handler :around ((v inspector::inspector-view) where)
  198.   (maybe-click-to-copy v v where #'(lambda() (when (next-method-p) (call-next-method)))))
  199.  
  200. (defmethod give-text? ((v inspector::inspector-view)) t)
  201.  
  202. ; Support the list definitions dialog
  203. (defmethod give-text? ((v menu-of-defs-dialog))
  204.   (let ((seq (do-subviews (sv v 'sequence-dialog-item) (return sv))))
  205.     (and seq
  206.          (view-contains-point-p seq (view-mouse-position v)))))
  207.  
  208. (defmethod give-text ((w menu-of-defs-dialog))
  209.   (let* ((v (do-subviews (sv w 'sequence-dialog-item) (return sv)))
  210.          (cell (point-to-cell v (view-mouse-position w)))
  211.          (package (or (window-package (slot-value w 'my-window)) *package*))
  212.          (contents (let ((*package* package))
  213.                      (read-from-string (car (cell-contents v cell))))))
  214.     (when cell
  215.       (let ((function (if (consp contents) (car contents) contents)))
  216.         (when (fboundp function)
  217.           (setq function (symbol-function function))
  218.           (setq * function)
  219.           (if (consp contents)
  220.             (let ((method (ignore-errors
  221.                            (nth-value 
  222.                             1 (%trace-function-spec-p
  223.                                (cons :method contents))))))
  224.               (when method (setq * method)))))))
  225.     (when (consp contents) (setq contents (car contents)))
  226.     (when cell
  227.       (format nil "~a" contents))))
  228.